home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scqquote.sc < prev    next >
Text File  |  1991-10-11  |  4KB  |  108 lines
  1. ;;; The functions in this module implement QUASIQUOTE as defined in section
  2. ;;; 7.1.4 of Revised**3.
  3.  
  4. ;*              Copyright 1989 Digital Equipment Corporation
  5. ;*                         All Rights Reserved
  6. ;*
  7. ;* Permission to use, copy, and modify this software and its documentation is
  8. ;* hereby granted only under the following terms and conditions.  Both the
  9. ;* above copyright notice and this permission notice must appear in all copies
  10. ;* of the software, derivative works or modified versions, and any portions
  11. ;* thereof, and both notices must appear in supporting documentation.
  12. ;*
  13. ;* Users of this software agree to the terms and conditions set forth herein,
  14. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  15. ;* right and license under any changes, enhancements or extensions made to the
  16. ;* core functions of the software, including but not limited to those affording
  17. ;* compatibility with other hardware or software environments, but excluding
  18. ;* applications which incorporate this software.  Users further agree to use
  19. ;* their best efforts to return to Digital any such changes, enhancements or
  20. ;* extensions that they make and inform Digital of noteworthy uses of this
  21. ;* software.  Correspondence should be provided to Digital at:
  22. ;* 
  23. ;*                       Director of Licensing
  24. ;*                       Western Research Laboratory
  25. ;*                       Digital Equipment Corporation
  26. ;*                       100 Hamilton Avenue
  27. ;*                       Palo Alto, California  94301  
  28. ;* 
  29. ;* This software may be distributed (but not offered for sale or transferred
  30. ;* for compensation) to third parties, provided such third parties agree to
  31. ;* abide by the terms and conditions of this notice.  
  32. ;* 
  33. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  34. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  35. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  36. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  37. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  38. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  39. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  40. ;* SOFTWARE.
  41.  
  42. (module scqquote (top-level QUASIQUOTATION))
  43.  
  44. (include "repdef.sc")
  45.  
  46. (define (QUASIQUOTATION d exp)
  47.     (if (islist exp 2 2)
  48.     (template d (cadr exp))
  49.     (error 'quasiquote "Illegal form: ~s" exp)))
  50.  
  51. (define (TEMPLATE d exp)
  52.     (cond ((zero? d)
  53.        exp)
  54.       ((and (pair? exp) (eq? (car exp) 'unquote))
  55.        (if (islist exp 2 2)
  56.            (if (eq? d 1)
  57.            (template (- d 1) (cadr exp))
  58.            (list 'list ''unquote (template (- d 1) (cadr exp))))
  59.            (error 'unquote "Illegal form: ~s" (cadr exp))))
  60.       ((vector? exp)
  61.        (vector-template d exp))
  62.       ((pair? exp)
  63.        (list-template d exp))
  64.       ((or (char? exp) (number? exp) (string? exp))
  65.        exp)
  66.       (else
  67.        (list 'quote exp))))
  68.  
  69. (define (LIST-TEMPLATE d exp)
  70.     (cond ((and (islist exp 2 2) (eq? (car exp) 'quote) (pair? (cadr exp))
  71.         (eq? (caadr exp) 'quasiquote))
  72.        (quasiquotation d (cadr exp)))
  73.       ((eq? (car exp) 'quasiquote)
  74.        (if (eq? d 0)
  75.            (quasiquotation (+ d 1) exp)
  76.            (list 'list ''quasiquote (quasiquotation (+ d 1) exp))))
  77.       (else (cons 'cons* (template-or-splice-list d exp)))))
  78.  
  79. (define (VECTOR-TEMPLATE d exp)
  80.     (list 'list->vector
  81.       (cons 'cons* (template-or-splice-list d (vector->list exp)))))
  82.  
  83. (define (TEMPLATE-OR-SPLICE-LIST d exp)
  84.     (cond ((null? exp) '('()))
  85.       ((pair? exp)
  86.        (cond ((eq? (car exp) 'unquote)
  87.           (list (template d exp)))
  88.          ((and (pair? (car exp)) (eq? (caar exp) 'unquote-splicing))
  89.           (list (list 'append
  90.                   (template-or-splice d (car exp))
  91.                   (cons 'cons*
  92.                     (template-or-splice-list d (cdr exp))))))
  93.          (else (cons (template-or-splice d (car exp))
  94.                  (template-or-splice-list d (cdr exp))))))
  95.       (else (list (template-or-splice d exp)))))
  96.  
  97. (define (TEMPLATE-OR-SPLICE d exp)
  98.     (if (and (pair? exp) (eq? (car exp) 'unquote-splicing))
  99.     (if (islist exp 2 2)
  100.         (if (eq? d 1)
  101.         (template (- d 1) (cadr exp))
  102.         (list 'list (list 'list ''unquote-splicing
  103.                   (template (- d 1) (cadr exp)))))
  104.         (error 'unquote-splicing "Illegal form: ~s" exp))
  105.     (template d exp)))
  106.  
  107. (install-expander 'QUASIQUOTE (lambda (x e) (e (quasiquotation 1 x) e)))
  108.